home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / tcl / tcl67.lha / tcl6.7 / library / init.tcl next >
Text File  |  1992-10-22  |  6KB  |  223 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # $Header: /user6/ouster/tcl/scripts/RCS/init.tcl,v 1.12 92/10/22 12:04:50 ouster Exp $ SPRITE (Berkeley)
  7. #
  8. # Copyright 1991-1992 Regents of the University of California
  9. # Permission to use, copy, modify, and distribute this
  10. # software and its documentation for any purpose and without
  11. # fee is hereby granted, provided that this copyright
  12. # notice appears in all copies.  The University of California
  13. # makes no representations about the suitability of this
  14. # software for any purpose.  It is provided "as is" without
  15. # express or implied warranty.
  16. #
  17.  
  18. # unknown:
  19. # Invoked when a Tcl command is invoked that doesn't exist in the
  20. # interpreter:
  21. #
  22. #    1. See if the autoload facility can locate the command in a
  23. #       Tcl script file.  If so, load it and execute it.
  24. #    2. See if the command exists as an executable UNIX program.
  25. #       If so, "exec" the command.
  26. #    3. If the command was invoked at top-level:
  27. #        (a) see if the command requests csh-like history substitution
  28. #        in one of the common forms !!, !<number>, or ^old^new.  If
  29. #        so, emulate csh's history substitution.
  30. #        (b) see if the command is a unique abbreviation for another
  31. #        command.  If so, invoke the command.
  32.  
  33. proc unknown args {
  34.     global auto_noexec auto_noload env unknown_pending;
  35.  
  36.     set name [lindex $args 0]
  37.     if ![info exists auto_noload] {
  38.     #
  39.     # Make sure we're not trying to load the same proc twice.
  40.     #
  41.     if [info exists unknown_pending($name)] {
  42.         unset unknown_pending($name)
  43.         if ![array size unknown_pending] {
  44.         unset unknown_pending
  45.         }
  46.         error "self-referential recursion in \"unknown\" for command \"$name\"";
  47.     }
  48.     set unknown_pending($name) pending;
  49.     set ret [auto_load $name];
  50.     unset unknown_pending($name);
  51.     if ![array size unknown_pending] {
  52.         unset unknown_pending
  53.     }
  54.     if $ret {
  55.         return [uplevel $args]
  56.     }
  57.     }
  58.     if ![info exists auto_noexec] {
  59.     if [auto_execok $name] {
  60.         return [uplevel exec $args]
  61.     }
  62.     }
  63.     if {([info level] == 1) && ([info script] == "")} {
  64.     if {$name == "!!"} {
  65.         return [uplevel {history redo}]
  66.     }
  67.     if [regexp {^!(.+)$} $name dummy event] {
  68.         return [uplevel history redo $event]
  69.     }
  70.     if [regexp {^\^(.*)\^(.*)^?$} $name dummy old new] {
  71.         return [uplevel history substitute $old $new]
  72.     }
  73.     set cmds [info commands $name*]
  74.     if {[llength $cmds] == 1} {
  75.         return [uplevel [lreplace $args 0 0 $cmds]]
  76.     }
  77.     if {[llength $cmds] != 0} {
  78.         if {$name == ""} {
  79.         error "empty command name \"\""
  80.         } else {
  81.         error "ambiguous command name \"$name\": [lsort $cmds]"
  82.         }
  83.     }
  84.     }
  85.     error "invalid command name \"$name\""
  86. }
  87.  
  88. # auto_load:
  89. # Checks a collection of library directories to see if a procedure
  90. # is defined in one of them.  If so, it sources the appropriate
  91. # library file to create the procedure.  Returns 1 if it successfully
  92. # loaded the procedure, 0 otherwise.
  93.  
  94. proc auto_load cmd {
  95.     global auto_index auto_oldpath auto_path env
  96.  
  97.     if [info exists auto_index($cmd)] {
  98.     uplevel #0 source $auto_index($cmd)
  99.     return 1
  100.     }
  101.     if [catch {set path $auto_path}] {
  102.     if [catch {set path $env(TCLLIBPATH)}] {
  103.         if [catch {set path [info library]}] {
  104.         return 0
  105.         }
  106.     }
  107.     }
  108.     if [info exists auto_oldpath] {
  109.     if {$auto_oldpath == $path} {
  110.         return 0
  111.     }
  112.     }
  113.     set auto_oldpath $path
  114.     catch {unset auto_index}
  115.     foreach dir $path {
  116.     set f ""
  117.     catch {
  118.         set f [open $dir/tclIndex]
  119.         if {[gets $f] != "# Tcl autoload index file: each line identifies a Tcl"} {
  120.         puts stdout "Bad id line in file $dir/tclIndex"
  121.         error done
  122.         }
  123.         while {[gets $f line] >= 0} {
  124.         if {([string index $line 0] == "#") || ([llength $line] != 2)} {
  125.             continue
  126.         }
  127.         set name [lindex $line 0]
  128.         if {![info exists auto_index($name)]} {
  129.             set auto_index($name) $dir/[lindex $line 1]
  130.         }
  131.         }
  132.     }
  133.     if {$f != ""} {
  134.         close $f
  135.     }
  136.     }
  137.     if [info exists auto_index($cmd)] {
  138.     uplevel #0 source $auto_index($cmd)
  139.     return 1
  140.     }
  141.     return 0
  142. }
  143.  
  144. # auto_execok:
  145. # Returns 1 if there's an executable in the current path for the
  146. # given name, 0 otherwise.  Builds an associative array auto_execs
  147. # that caches information about previous checks, for speed.
  148.  
  149. proc auto_execok name {
  150.     global auto_execs env
  151.  
  152.     if [info exists auto_execs($name)] {
  153.     return $auto_execs($name)
  154.     }
  155.     set auto_execs($name) 0
  156.     foreach dir [split $env(PATH) :] {
  157.     if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  158.         set auto_execs($name) 1
  159.         return 1
  160.     }
  161.     }
  162.     return 0
  163. }
  164.  
  165. # auto_reset:
  166. # Destroy all cached information for auto-loading and auto-execution,
  167. # so that the information gets recomputed the next time it's needed.
  168. # Also delete any procedures that are listed in the auto-load index
  169. # except those related to auto-loading.
  170.  
  171. proc auto_reset {} {
  172.     global auto_execs auto_index auto_oldpath
  173.     foreach p [info procs] {
  174.     if {[info exists auto_index($p)] && ($p != "unknown")
  175.         && ![string match auto_* $p]} {
  176.         rename $p {}
  177.     }
  178.     }
  179.     catch {unset auto_execs}
  180.     catch {unset auto_index}
  181.     catch {unset auto_oldpath}
  182. }
  183.  
  184. # auto_mkindex:
  185. # Regenerate a tclIndex file from Tcl source files.  Takes two arguments:
  186. # the name of the directory in which the tclIndex file is to be placed,
  187. # and a glob pattern to use in that directory to locate all of the relevant
  188. # files.
  189.  
  190. proc auto_mkindex {dir files} {
  191.     global errorCode errorInfo
  192.     set oldDir [pwd]
  193.     cd $dir
  194.     set dir [pwd]
  195.     append index "# Tcl autoload index file: each line identifies a Tcl\n"
  196.     append index "# procedure and the file where that procedure is\n"
  197.     append index "# defined.  Generated by the \"auto_mkindex\" command.\n"
  198.     append index "\n"
  199.     foreach file [glob $files] {
  200.     set f ""
  201.     set error [catch {
  202.         set f [open $file]
  203.         while {[gets $f line] >= 0} {
  204.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  205.             append index "[list $procName $file]\n"
  206.         }
  207.         }
  208.         close $f
  209.     } msg]
  210.     if $error {
  211.         set code $errorCode
  212.         set info $errorInfo
  213.         catch [close $f]
  214.         cd $oldDir
  215.         error $msg $info $code
  216.     }
  217.     }
  218.     set f [open tclIndex w]
  219.     puts $f $index nonewline
  220.     close $f
  221.     cd $oldDir
  222. }
  223.